Progress bar with remaining time

Hi everyone

I've managed to pull together a nice simple progress bar to let users know how long it will take to collate certain data. Example below:

Sub ProgressBar()

frmProgressBar.Show

End Sub

Sub Main()

Application.ScreenUpdating = False

Dim pctCnt As Integer
Dim cnt As Integer
Dim Completed As Single

pctCnt = 1
For cnt = 1 To 100
For a = 1 To 500000
Next
pctCnt = pctCnt + 1
Completed = pctCnt / 100
frmProgressBar.LabelProgress.Width = Completed * frmProgressBar.Width

'START OF CODE

Dim rCell As Range

For Each rCell In Range("A1:A400")

rCell.Select

Next rCell


'END OF CODE

DoEvents
Next
Unload frmProgressBar

Application.ScreenUpdating = True

End Sub

Does anyone know how to show elapsed time remaining....

Thanks in advance